home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
DATETIME
/
DRAWC13
/
DRAWC13.ZIP
/
DrawCalendar.pas
< prev
Wrap
Pascal/Delphi Source File
|
1996-06-23
|
21KB
|
691 lines
// Version 1.3
//
// TDrawCalendar is a component based on though not descended from the
// Calendar in the Samples page of the pallette. I wanted to unpublish the font
// property which meant I could not descend it directly. Therefore a lot of
// this code is identical to that of the TCalendar component. I have put all original
// code at the end of the listing where possible, and highlighted changes to the TCalendar code.
//
// TDrawCalendar is my first component so I do not expect it to be perfect. My programming
// techniques and style may also be questionable as I am not a professional developer
// but a home taught one who enjoys programming in my spare time.
//
// The purpose of this component is to add flexibility to the calendar component
// to allow:
// 1. Drawing bitmaps, Icons and text onto particular dates of the calendar.
// 2. Allow font setting for the Days of the week, Date numbers and added text
// as three separate properties (HeaderFont, DateFont and TextFont resp.).
//
//
unit DrawCalendar;
interface
uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
Grids, SysUtils;
type
TDayOfWeek = 0..6;
type
TCoordResults = (crXIcon, crYIcon, crXText, crYText, crXColor, crYColor);
TDrawCalendar = class(TCustomGrid)
private
// From Calendar sample component
FDate: TDateTime;
FMonthOffset: Integer;
FOnChange: TNotifyEvent;
FReadOnly: Boolean;
FStartOfWeek: TDayOfWeek;
FUpdating: Boolean;
FUseCurrentDate: Boolean;
// These are needed for DrawCalendar
FDateBox : Boolean;
FLongDay : Boolean;
FOnDrawCell : TDrawCellEvent;
FHeaderFont : TFont;
FTextFont : TFont;
FDateFont : TFont;
FCol0Color : TColor;
FCol1Color : TColor;
FCol2Color : TColor;
FCol3Color : TColor;
FCol4Color : TColor;
FCol5Color : TColor;
FCol6Color : TColor;
// From Calendar sample component
function GetCellText(ACol, ARow: Integer): string;
function GetDateElement(Index: Integer): Integer;
procedure SetCalendarDate(Value: TDateTime);
procedure SetDateElement(Index: Integer; Value: Integer);
procedure SetStartOfWeek(Value: TDayOfWeek);
procedure SetUseCurrentDate(Value: Boolean);
function StoreCalendarDate: Boolean;
procedure SetHeaderFont(AFont : Tfont);
procedure SetTextFont(AFont : Tfont);
procedure SetDateFont(AFont : Tfont);
procedure SetDateBox(Value : Boolean);
procedure SetLongDay(Value : Boolean);
procedure SetCol0Color(AColor : TColor);
procedure SetCol1Color(AColor : TColor);
procedure SetCol2Color(AColor : TColor);
procedure SetCol3Color(AColor : TColor);
procedure SetCol4Color(AColor : TColor);
procedure SetCol5Color(AColor : TColor);
procedure SetCol6Color(AColor : TColor);
protected
// These are straight from the calendar sample component
procedure Change; dynamic;
procedure ChangeMonth(Delta: Integer);
procedure Click; override;
function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
function DaysThisMonth: Integer; virtual;
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
property Font;
function IsLeapYear(AYear: Integer): Boolean; virtual;
function SelectCell(ACol, ARow: Longint): Boolean; override;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
// Specific items to DrawCalendar
Function GetCoords(TheDate : TDateTime; index : TCoordResults) : Integer;
function StrAsPChar(var S: Openstring): PChar;
public
constructor Create(AOwner: TComponent); override;
property CalendarDate: TDateTime read FDate write SetCalendarDate stored StoreCalendarDate;
property CellText[ACol, ARow: Integer]: string read GetCellText;
procedure NextMonth;
procedure NextYear;
procedure PrevMonth;
procedure PrevYear;
procedure UpdateCalendar; virtual;
// These are for The DrawCalendar
function PasteBitmap(TheDate : TDateTime; TheBitmap : TBitmap) : Boolean;
function PasteIcon(TheDate : TDateTime; TheIcon : TIcon) : Boolean;
function PasteText(TheDate : TDateTime; MyText : string) : Boolean;
function IsCurrentMonth(TheDate: TDateTime): Boolean;
property canvas;
published
property Align;
property BorderStyle;
property Color;
property Ctl3D;
property Day: Integer index 3 read GetDateElement write SetDateElement stored False;
property Enabled;
property GridLineWidth;
property Month: Integer index 2 read GetDateElement write SetDateElement stored False;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
property ShowHint;
property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
property TabOrder;
property TabStop;
property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
property Visible;
property Year: Integer index 1 read GetDateElement write SetDateElement stored False;
property OnClick;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseUp;
property OnMouseMove;
//Specific to DrawCalendar
property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOndrawCell;
property DefaultColWidth;
property DefaultRowHeight;
property HeaderFont : TFont read FHeaderFont write SetHeaderFont;
property TextFont : TFont read FTextFont write SetTextFont;
property DateFont : TFont read FDateFont write SetDateFont;
property DateBox : Boolean read FDateBox write SetDateBox default true;
property ColumnColor0 : TColor read FCol0color write SetCol0Color;
property ColumnColor1 : TColor read FCol1color write SetCol1Color;
property ColumnColor2 : TColor read FCol2color write SetCol2Color;
property ColumnColor3 : TColor read FCol3color write SetCol3Color;
property ColumnColor4 : TColor read FCol4color write SetCol4Color;
property ColumnColor5 : TColor read FCol5color write SetCol5Color;
property ColumnColor6 : TColor read FCol6color write SetCol6Color;
property UseLongDayNames : Boolean read FLongDay write SetLongDay default False;
end;
procedure Register;
implementation
constructor TDrawCalendar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
{ defaults }
FDateBox := True;
FLongDay := False;
FHeaderFont := TFont.create;
FTextFont := TFont.create;
FDateFont := TFont.create;
FCol0Color := clNone;
FCol1Color := clNone;
FCol2Color := clNone;
FCol3Color := clNone;
FCol4Color := clNone;
FCol5Color := clNone;
FCol6Color := clNone;
FUseCurrentDate := True;
HeaderFont.size := 12;
DateFont.color := clRed;
DateFont.name := 'Times New Roman';
TextFont.color := clBlue;
FixedCols := 0;
FixedRows := 1;
ColCount := 7;
RowCount := 7;
ScrollBars := ssNone;
Options := Options - [goRangeSelect] + [goDrawFocusSelected];
FDate := Date;
UpdateCalendar;
// Refers to DrawCalendar
DefaultColWidth := 84;
DefaultRowHeight := 50;
end;
procedure TDrawCalendar.Change;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
procedure TDrawCalendar.Click;
var
TheCellText: string;
begin
inherited Click;
TheCellText := CellText[Col, Row];
if TheCellText <> '' then Day := StrToInt(TheCellText);
end;
function TDrawCalendar.IsLeapYear(AYear: Integer): Boolean;
begin
Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;
function TDrawCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
const
DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
Result := DaysInMonth[AMonth];
if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
end;
function TDrawCalendar.DaysThisMonth: Integer;
begin
Result := DaysPerMonth(Year, Month);
end;
procedure TDrawCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
TheText: string;
begin
if (ARow <> 0) then
begin //Set Column colors for girds containing date numbers
if (ACol = 0 ) and (ColumnColor0 <> clNone) then
Canvas.Brush.color := ColumnColor0;
if (ACol = 1 ) and (ColumnColor1 <> clNone) then
Canvas.Brush.color := ColumnColor1;
if (ACol = 2 ) and (ColumnColor2 <> clNone) then
Canvas.Brush.color := ColumnColor2;
if (ACol = 3 ) and (ColumnColor3 <> clNone) then
Canvas.Brush.color := ColumnColor3;
if (ACol = 4 ) and (ColumnColor4 <> clNone) then
Canvas.Brush.color := ColumnColor4;
if (ACol = 5 ) and (ColumnColor5 <> clNone) then
Canvas.Brush.color := ColumnColor5;
if (ACol = 6 ) and (ColumnColor6 <> clNone) then
Canvas.Brush.color := ColumnColor6;
end;
TheText := CellText[ACol, ARow];
with ARect, Canvas do begin
if ARow = 0 then
begin
font := HeaderFont;
TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
font := TextFont;
end else
if TheText <> '' then
begin
font := DateFont;
TextRect(ARect, Left + 3, Top, TheText);
if DateBox then
begin
Self.Canvas.MoveTo(Left, Top + TextHeight('N'));
LineTo(Left + (TextWidth('N')*2), Top + (TextHeight('N')));
LineTo(Left + (TextWidth('N')*2), Top - 1);
end;
font := TextFont;
end else
if TheText = '' then
begin
if (ARow <> 0) then
begin // This code takes care of those cells without a date number.
if (ACol = 0 ) and (ColumnColor0 <> clNone) then
begin
Canvas.Brush.color := ColumnColor0;
TextRect(ARect, Left + 3, Top, '');
end;
if (ACol = 1 ) and (ColumnColor1 <> clNone) then
begin
Canvas.Brush.color := ColumnColor1;
TextRect(ARect, Left + 3, Top, '');
end;
if (ACol = 2 ) and (ColumnColor2 <> clNone) then
Begin
Canvas.Brush.color := ColumnColor2;
TextRect(ARect, Left + 3, Top, '');
end;
if (ACol = 3 ) and (ColumnColor3 <> clNone) then
Begin
Canvas.Brush.color := ColumnColor3;
TextRect(ARect, Left + 3, Top, '');
end;
if (ACol = 4 ) and (ColumnColor4 <> clNone) then
Begin
Canvas.Brush.color := ColumnColor4;
TextRect(ARect, Left + 3, Top, '');
end;
if (ACol = 5 ) and (ColumnColor5 <> clNone) then
Begin
Canvas.Brush.color := ColumnColor5;
TextRect(ARect, Left + 3, Top, '');
end;
if (ACol = 6 ) and (ColumnColor6 <> clNone) then
Begin
Canvas.Brush.color := ColumnColor6;
TextRect(ARect, Left + 3, Top, '');
end;
end;
end;
end;
if Assigned(FOnDrawCell) then FOnDrawCell(Self, ACol, ARow, ARect, AState);
end;
function TDrawCalendar.GetCellText(ACol, ARow: Integer): string;
var
DayNum: Integer;
begin
if ARow = 0 then { day names at tops of columns }
if UseLongDayNames then
Result := LongDayNames[(StartOfWeek + ACol) mod 7 + 1] else
Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
else
begin
DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
else Result := IntToStr(DayNum);
end;
end;
function TDrawCalendar.SelectCell(ACol, ARow: Longint): Boolean;
begin
if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
Result := False
else Result := inherited SelectCell(ACol, ARow);
end;
procedure TDrawCalendar.SetCalendarDate(Value: TDateTime);
begin
FDate := Value;
UpdateCalendar;
Change;
end;
function TDrawCalendar.StoreCalendarDate: Boolean;
begin
Result := not FUseCurrentDate;
end;
function TDrawCalendar.GetDateElement(Index: Integer): Integer;
var
AYear, AMonth, ADay: Word;
begin
DecodeDate(FDate, AYear, AMonth, ADay);
case Index of
1: Result := AYear;
2: Result := AMonth;
3: Result := ADay;
else Result := -1;
end;
end;
procedure TDrawCalendar.SetDateElement(Index: Integer; Value: Integer);
var
AYear, AMonth, ADay: Word;
begin
if Value > 0 then
begin
DecodeDate(FDate, AYear, AMonth, ADay);
case Index of
1: if AYear <> Value then AYear := Value else Exit;
2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
else Exit;
end;
FDate := EncodeDate(AYear, AMonth, ADay);
FUseCurrentDate := False;
UpdateCalendar;
Change;
end;
end;
procedure TDrawCalendar.SetStartOfWeek(Value: TDayOfWeek);
begin
if Value <> FStartOfWeek then
begin
FStartOfWeek := Value;
UpdateCalendar;
end;
end;
procedure TDrawCalendar.SetUseCurrentDate(Value: Boolean);
begin
if Value <> FUseCurrentDate then
begin
FUseCurrentDate := Value;
if Value then
begin
FDate := Date; { use the current date, then }
UpdateCalendar;
end;
end;
end;
{ Given a value of 1 or -1, moves to Next or Prev month accordingly }
procedure TDrawCalendar.ChangeMonth(Delta: Integer);
var
AYear, AMonth, ADay: Word;
NewDate: TDateTime;
CurDay: Integer;
begin
DecodeDate(FDate, AYear, AMonth, ADay);
CurDay := ADay;
if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
else ADay := 1;
NewDate := EncodeDate(AYear, AMonth, ADay);
NewDate := NewDate + Delta;
DecodeDate(NewDate, AYear, AMonth, ADay);
if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
else ADay := DaysPerMonth(AYear, AMonth);
CalendarDate := EncodeDate(AYear, AMonth, ADay);
end;
procedure TDrawCalendar.PrevMonth;
begin
ChangeMonth(-1);
end;
procedure TDrawCalendar.NextMonth;
begin
ChangeMonth(1);
end;
procedure TDrawCalendar.NextYear;
begin
if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
Year := Year + 1;
end;
procedure TDrawCalendar.PrevYear;
begin
if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
Year := Year - 1;
end;
procedure TDrawCalendar.UpdateCalendar;
var
AYear, AMonth, ADay: Word;
FirstDate: TDateTime;
begin
FUpdating := True;
try
DecodeDate(FDate, AYear, AMonth, ADay);
FirstDate := EncodeDate(AYear, AMonth, 1);
FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
if FMonthOffset = 2 then FMonthOffset := -5;
MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
False, False);
Invalidate;
finally
FUpdating := False;
end;
end;
procedure TDrawCalendar.WMSize(var Message: TWMSize);
var
GridLines: Integer;
begin
GridLines := 6 * GridLineWidth;
DefaultColWidth := (Message.Width - GridLines) div 7;
DefaultRowHeight := (Message.Height - GridLines) div 7;
end;
// SPECIFIC TO DRAW CALENDAR
procedure TDrawCalendar.SetDateBox(Value : Boolean);
begin
if FDateBox <> Value then
begin
FDateBox := Value;
Invalidate;
end;
end;
procedure TDrawCalendar.SetLongDay(Value : Boolean);
begin
if FLongDay <> Value then
begin
FLongDay := Value;
Invalidate;
end;
end;
// This function get the x & y coords for drawing the Icon, Bitmap and text
// Onto the DrawCalendar depending upon the date paramenter
function TDrawCalendar.GetCoords(TheDate : TDateTime;
index : TCoordResults) : Integer;
Var vDay, vMonth, vYear : Word;
Column , Row : integer;
CellTextString : string[10];
begin
try
Result := 0;
DecodeDate(TheDate, vYear, vMonth, vDay);
for Row := 1 to 6 do // Iterate through cells to find required date.
for Column := 0 to 6 do
begin
CellTextString := GetCellText(Column,Row);
if (CellTextString <> '') and (Strlen(StrAsPChar(CelltextString)) <=2) then
If (STrToInt(CelltextString) = vDay) and (Year = vYear) then
case index of //Return coord depending upon whicjh is required.
crXIcon :
Result := (Column * DefaultColWidth) +
(DefaultColWidth - 2) + Column;
crYIcon :
Result := (Row * DefaultRowHeight) + Row + 1;
crXText :
Result := (Column * DefaultColWidth) + 2 + Column;
crYText :
Result := (Row * DefaultRowHeight) +
(DefaultRowHeight - 8) + Row;
crXColor :
Result := (Column * DefaultColWidth) + Column;
crYColor :
Result := (Row * DefaultRowHeight) + Row;
end;
end;
except
Result := 0;
end;
end;
procedure TDrawCalendar.SetHeaderFont(AFont : Tfont);
begin
FHeaderFont.Assign(AFont);
Invalidate;
end;
procedure TDrawCalendar.SetTextFont(AFont : Tfont);
begin
FTextFont.Assign(AFont);
Invalidate;
end;
procedure TDrawCalendar.SetDateFont(AFont : Tfont);
begin
FDateFont.Assign(AFont);
Invalidate;
end;
procedure TDrawCalendar.SetCol0Color(AColor : TColor);
begin
FCol0Color := AColor;
Invalidate;
end;
procedure TDrawCalendar.SetCol1Color(AColor : TColor);
begin
FCol1Color := AColor;
Invalidate;
end;
procedure TDrawCalendar.SetCol2Color(AColor : TColor);
begin
FCol2Color := AColor;
Invalidate;
end;
procedure TDrawCalendar.SetCol3Color(AColor : TColor);
begin
FCol3Color := AColor;
Invalidate;
end;
procedure TDrawCalendar.SetCol4Color(AColor : TColor);
begin
FCol4Color := AColor;
Invalidate;
end;
procedure TDrawCalendar.SetCol5Color(AColor : TColor);
begin
FCol5Color := AColor;
Invalidate;
end;
procedure TDrawCalendar.SetCol6Color(AColor : TColor);
begin
FCol6Color := AColor;
Invalidate;
end;
Function TDrawCalendar.PasteBitmap(TheDate : TDateTime; TheBitmap : TBitmap) : Boolean;
begin
try
if IsCurrentMonth(TheDate) then
begin
Canvas.Draw(GetCoords(TheDate, crXIcon) - TheBitmap.width,GetCoords(TheDate, crYIcon), TheBitmap);
Result := True;
end else Result := False;
except
Result := False;
end;
end;
function TDrawCalendar.PasteIcon(TheDate : TDateTime; TheIcon : TIcon) : Boolean;
begin
try
if IsCurrentMonth(TheDate) then
begin
Canvas.Draw(GetCoords(TheDate, crXIcon),GetCoords(TheDate, crYIcon), TheIcon);
Result := True;
end else Result := False;
except
Result := False;
end;
end;
function TDrawCalendar.PasteText(TheDate : TDateTime; MyText : string) : Boolean;
Var
TextOffset : Integer;
begin
try
setbkmode(canvas.handle, TRANSPARENT);
if IsCurrentMonth(TheDate) then
begin
case font.size of
1..7: TextOffSet := 3;
8: TextOffSet := 7;
9: TextOffset := 8;
10..11: TextOffset := 9;
12 : TextOffset := 12;
13..22: TextOffSet := Font.Size + 2;
else
TextOffset := 1;
end;
font := Textfont;
Canvas.TextOut(GetCoords(TheDate, crXText), GetCoords(TheDate, crYText) - TextOffset, MyText);
Result := True;
end else Result := False;
except
Result := False;
end;
end;
function TDrawCalendar.IsCurrentMonth(TheDate: TDateTime): Boolean;
Var
vday, vmonth, vyear : Word;
begin
try
DecodeDate(TheDate, vYear, vMonth, vDay);
If (Month = vMonth) and (Year = vYear) then
Result := True else
Result := False;
except
Result := False;
end;
end;
function TDrawCalendar.StrAsPChar(var S: Openstring): PChar;
//Function to convert a string to a pChar.
//This function was borrowed from Delphi Developers Guide by
// Pacheco & Teixeira
begin
if length(S) = High(S) then Dec(S[0]);
S[Ord(Length(S)) + 1] := #0;
Result := @S[1];
end;
procedure Register;
begin
RegisterComponents('S2', [TDrawCalendar]);
end;
end.